home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / gls / require.scm < prev    next >
Encoding:
Text File  |  1995-08-17  |  10.7 KB  |  347 lines
  1. ;;;; Implementation of VICINITY and MODULES for Scheme
  2. ;Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define *SLIB-VERSION* "2a2")
  21.  
  22. ;;; Standardize msdos -> ms-dos.
  23. (define software-type
  24.   (cond ((eq? 'msdos (software-type))
  25.      (lambda () 'ms-dos))
  26.     (else software-type)))
  27.  
  28. (define (user-vicinity)
  29.   (case (software-type)
  30.     ((VMS)    "[.]")
  31.     (else    "")))
  32.  
  33. (define program-vicinity
  34.   (let ((*vicinity-suffix*
  35.      (case (software-type)
  36.        ((NOSVE)    '(#\: #\.))
  37.        ((AMIGA)    '(#\: #\/))
  38.        ((UNIX)    '(#\/))
  39.        ((VMS)    '(#\: #\]))
  40.        ((MS-DOS WINDOWS ATARIST OS/2)    '(#\\))
  41.        ((MACOS THINKC)    '(#\:)))))
  42.     (lambda ()
  43.       (let loop ((i (- (string-length *load-pathname*) 1)))
  44.     (cond ((negative? i) "")
  45.           ((memv (string-ref *load-pathname* i)
  46.              *vicinity-suffix*)
  47.            (substring *load-pathname* 0 (+ i 1)))
  48.           (else (loop (- i 1))))))))
  49.  
  50. (define sub-vicinity
  51.   (case (software-type)
  52.     ((VMS)
  53.      (lambda
  54.       (vic name)
  55.       (let ((l (string-length vic)))
  56.     (if (or (zero? (string-length vic))
  57.         (not (char=? #\] (string-ref vic (- l 1)))))
  58.         (string-append vic "[" name "]")
  59.         (string-append (substring vic 0 (- l 1))
  60.                "." name "]")))))
  61.     (else
  62.      (let ((*vicinity-suffix*
  63.         (case (software-type)
  64.           ((NOSVE) ".")
  65.           ((UNIX AMIGA) "/")
  66.           ((MACOS THINKC) ":")
  67.           ((MS-DOS WINDOWS ATARIST OS/2) "\\"))))
  68.        (lambda (vic name)
  69.      (string-append vic name *vicinity-suffix*))))))
  70.  
  71. (define (make-vicinity <pathname>) <pathname>)
  72.  
  73. (define *catalog*
  74.   (map
  75.    (lambda (p)
  76.      (if (symbol? (cdr p)) p
  77.      (cons
  78.       (car p)
  79.       (if (pair? (cdr p))
  80.           (cons 
  81.            (cadr p)
  82.            (in-vicinity (library-vicinity) (cddr p)))
  83.           (in-vicinity (library-vicinity) (cdr p))))))
  84.    '(
  85.      (rev4-optional-procedures    .    "sc4opt")
  86.      (rev2-procedures        .    "sc2")
  87.      (multiarg/and-        .    "mularg")
  88.      (multiarg-apply        .    "mulapply")
  89.      (rationalize        .    "ratize")
  90.      (transcript        .    "trnscrpt")
  91.      (with-file            .    "withfile")
  92.      (dynamic-wind        .    "dynwind")
  93.      (dynamic            .    "dynamic")
  94.      (fluid-let        macro    .    "fluidlet")
  95.      (alist            .    "alist")
  96.      (hash            .    "hash")
  97.      (sierpinski        .    "sierpinski")
  98.      (soundex            .    "soundex")
  99.      (hash-table        .    "hashtab")
  100.      (logical            .    "logical")
  101.      (random            .    "random")
  102.      (random-inexact        .    "randinex")
  103.      (modular            .    "modular")
  104.      (prime            .    "prime")
  105.      (charplot            .    "charplot")
  106.      (sort            .    "sort")
  107.      (common-list-functions    .    "comlist")
  108.      (tree            .    "tree")
  109.      (format            .    "format")
  110.      (format-inexact        .    "formatfl")
  111.      (generic-write        .    "genwrite")
  112.      (pretty-print        .    "pp")
  113.      (pprint-file        .    "ppfile")
  114.      (object->string        .    "obj2str")
  115.      (string-case        .    "strcase")
  116.      (stdio            .    "stdio")
  117.      (scanf            .    "scanf")
  118.      (line-i/o            .    "lineio")
  119.      (string-port        .    "strport")
  120.      (getopt            .    "getopt")
  121.      (debug            .    "debug")
  122.      (trace    defmacro    .    "trace")
  123. ;     (eval            .    "eval")
  124.      (record            .    "record")
  125.      (promise            .    "promise")
  126.      (synchk            .    "synchk")
  127.      (defmacroexpand        .    "defmacex")
  128.      (macro-by-example    defmacro    .    "mbe")
  129.      (syntax-case        .    "scainit")
  130.      (syntactic-closures    .    "scmacro")
  131.      (macros-that-work        .    "macwork")
  132.      (macro            .    macros-that-work)
  133.      (object            .    "object")
  134.      (record-object        .    "recobj")
  135.      (yasos        macro    .    "yasyn")
  136.      (oop            .    yasos)
  137.      (collect        macro    .    "collect")
  138.      (struct    defmacro    .    "struct")
  139.      (structure    syntax-case    .    "structure")
  140.      (values            .    "values")
  141.      (queue            .    "queue")
  142.      (priority-queue        .    "priorque")
  143.      (array            .    "array")
  144.      (array-for-each        .    "arraymap")
  145.      (repl            .    "repl")
  146.      (process            .    "process")
  147.      (test            .    "test")
  148.      (red-black-tree        .    "rbtree")
  149.      (chapter-order        .    "chap")
  150.      (posix-time        .    "time")
  151.      (common-lisp-time        .    "cltime")
  152.      (relational-database    .    "rdms")
  153.      (database-utilities    .    "dbutil")
  154.      (alist-table        .    "alistab")
  155.      (parameters        .    "paramlst")
  156.      (read-command        .    "comparse")
  157.      (match            .    "match-slib")
  158.      (match-slib        .    "match-slib")
  159.      (Gwish            .    "Gwish")
  160.      (generics            .     "generics")
  161.      )))
  162.  
  163. (set! *catalog*
  164.       (cons (cons 'portable-scheme-debugger
  165.           (in-vicinity (sub-vicinity (library-vicinity) "psd")
  166.                    "psd-slib"))
  167.         *catalog*))
  168.  
  169. (define *load-pathname* #f)
  170.  
  171. (define (slib:pathnameize-load *old-load*)
  172.   (lambda (<pathname> . extra)
  173.     (let ((old-load-pathname *load-pathname*))
  174.       (set! *load-pathname* <pathname>)
  175.       (apply *old-load* (cons <pathname> extra))
  176.       (require:provide <pathname>)
  177.       (set! *load-pathname* old-load-pathname))))
  178.  
  179. (set! slib:load-source
  180.       (slib:pathnameize-load slib:load-source))
  181. (set! slib:load
  182.       (slib:pathnameize-load slib:load))
  183.  
  184. ;;;; MODULES
  185.  
  186. (define *modules* '())
  187.  
  188. (define (require:provided? feature)
  189.   (if (symbol? feature)
  190.       (if (memq feature *features*) #t
  191.       (let ((path (cdr (or (assq feature *catalog*) '(#f . #f)))))
  192.         (and path (member path *modules*) #t)))
  193.       (and (member feature *modules*) #t)))
  194.  
  195. (define (require:feature->path feature)
  196.   (if (symbol? feature)
  197.       (if (memq feature *features*) #t
  198.       (let ((path (cdr (or (assq feature *catalog*) '(#f . #f)))))
  199.         (cond ((not path)
  200.            (set! feature (symbol->string feature))
  201.            (if (member feature *modules*) #t
  202.                feature))
  203.           ((symbol? path) (require:feature->path path))
  204.           ((member (if (pair? path) (cdr path) path) *modules*)
  205.            #t)
  206.           (else path))))
  207.       (if (member feature *modules*) #t
  208.       feature)))
  209.  
  210. (define (require:require feature)
  211.   (let ((path (require:feature->path feature)))
  212.     (cond ((eq? path #t) #t)
  213.       ((not path)
  214.        (newline)
  215.        (display ";required feature not supported: ")
  216.        (display feature)
  217.        (newline)
  218.        (slib:error ";required feature not supported: " feature))
  219.       ((not (pair? path))        ;simple name
  220.        (slib:load path)
  221.        (require:provide feature))
  222.       (else                ;special loads
  223.        (require (car path))
  224.        (apply (case (car path)
  225.             ((macro) macro:load)
  226.             ((syntactic-closures) synclo:load)
  227.             ((syntax-case) syncase:load)
  228.             ((macros-that-work) macwork:load)
  229.             ((macro-by-example) defmacro:load)
  230.             ((defmacro) defmacro:load)
  231.             ((source) slib:load-source)
  232.             ((compiled) slib:load-compiled))
  233.           (if (list? path) (cdr path) (list (cdr path))))
  234.        (require:provide feature)))))
  235.  
  236. (define (require:provide feature)
  237.   (if (symbol? feature)
  238.       (if (not (memq feature *features*))
  239.       (set! *features* (cons feature *features*)))
  240.       (if (not (member feature *modules*))
  241.       (set! *modules* (cons feature *modules*)))))
  242.  
  243. (require:provide 'vicinity)
  244.  
  245. (define provide require:provide)
  246. (define provided? require:provided?)
  247. (define require require:require)
  248.  
  249. ;;; Supported by all implementations
  250. (provide 'eval)
  251. (provide 'defmacro)
  252.  
  253. (if (and (string->number "0.0") (inexact? (string->number "0.0")))
  254.     (provide 'inexact))
  255. (if (rational? (string->number "1/19")) (provide 'rational))
  256. (if (real? (string->number "0.0")) (provide 'real))
  257. (if (complex? (string->number "1+i")) (provide 'complex))
  258. (let ((n (string->number "9999999999999999999999999999999")))
  259.   (if (and n (exact? n)) (provide 'bignum)))
  260.  
  261. (define current-time
  262.   (if (provided? 'current-time) current-time
  263.       (let ((c 0))
  264.     (lambda () (set! c (+ c 1)) c))))
  265. (define difftime (if (provided? 'current-time) difftime -))
  266. (define offset-time (if (provided? 'current-time) offset-time +))
  267.  
  268. (define report:print
  269.   (lambda args
  270.     (for-each (lambda (x) (write x) (display #\ )) args)
  271.     (newline)))
  272.  
  273. (define slib:report
  274.   (let ((slib:report (lambda () (slib:report-version) (slib:report-locations))))
  275.     (lambda args
  276.       (cond ((null? args) (slib:report))
  277.         ((not (string? (car args)))
  278.          (slib:report-version) (slib:report-locations #t))
  279.         ((require:provided? 'transcript)
  280.          (transcript-on (car args))
  281.          (slib:report)
  282.          (transcript-off))
  283.         ((require:provided? 'with-file)
  284.          (with-output-to-file (car args) slib:report))
  285.         (else (slib:report))))))
  286.  
  287. (define slib:report-version
  288.   (lambda ()
  289.     (report:print
  290.      'SLIB *SLIB-VERSION* 'on (scheme-implementation-type)
  291.      (scheme-implementation-version) 'on (software-type))))
  292.  
  293. (define slib:report-locations
  294.   (let ((features *features*) (catalog *catalog*))
  295.     (lambda args
  296.       (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
  297.       (report:print '(LIBRARY-VICINITY) 'is (library-vicinity))
  298.       (report:print '(SCHEME-FILE-SUFFIX) 'is (scheme-file-suffix))
  299.       (cond (*load-pathname*
  300.          (report:print '*LOAD-PATHNAME* 'is *load-pathname*)))
  301.       (cond ((not (null? *modules*))
  302.          (report:print 'Loaded '*MODULES* 'are: *modules*)))
  303.       (let* ((i (+ -1 5)))
  304.     (cond ((eq? (car features) (car *features*)))
  305.           (else (report:print 'loaded '*FEATURES* ':) (display slib:tab)))
  306.     (for-each
  307.      (lambda (x)
  308.        (cond ((eq? (car features) x)
  309.           (if (not (eq? (car features) (car *features*))) (newline))
  310.           (report:print 'Implementation '*FEATURES* ':)
  311.           (display slib:tab) (set! i (+ -1 5)))
  312.          ((zero? i) (newline) (display slib:tab) (set! i (+ -1 5)))
  313.          ((not (= (+ -1 5) i)) (display #\ )))
  314.        (write x) (set! i (+ -1 i)))
  315.      *features*))
  316.       (newline)
  317.       (let* ((i #t))
  318.     (cond ((not (eq? (car catalog) (car *catalog*)))
  319.            (report:print 'Additional '*CATALOG* ':)))
  320.     (cond ((or (pair? args) (not (eq? (car catalog) (car *catalog*))))
  321.            (for-each
  322.         (lambda (x)
  323.           (cond ((eq? (car catalog) x)
  324.              (report:print 'Implementation '*CATALOG* ':)
  325.              (set! i (pair? args))
  326.              (cond (i)
  327.                    (else (display slib:tab) (report:print x)
  328.                      (display slib:tab) (report:print '...)))))
  329.           (cond (i (display slib:tab) (report:print x))))
  330.         *catalog*))
  331.           (else (report:print 'Implementation '*CATALOG* ':)
  332.             (display slib:tab) (report:print (car *catalog*))
  333.             (display slib:tab) (report:print '...))))
  334.       (newline))))
  335.  
  336. (define (require-greeting)
  337.   (let ((sit (scheme-implementation-version)))
  338.     (cond ((zero? (string-length sit)))
  339.       ((or (not (string? sit)) (char=? #\? (string-ref sit 0)))
  340.        (newline)
  341.        (slib:report-version)
  342.        (report:print '(IMPLEMENTATION-VICINITY) 'is (implementation-vicinity))
  343.        (report:print 'type '(slib:report) 'for 'configuration)
  344.        (slib:report)
  345.        (newline)))))
  346.  
  347.